unit LogDelphi;

interface

uses SysUtils, Classes;

procedure GeneratePas();

implementation

uses MuUtils, LogData;

function DelphiPrefix(const VarType: TVarType): string;
begin
  Result := Iif(VarType.Code in [FIELD_STRING, FIELD_GUID], 'const ', '');
end;

function DelphiType(const VarType: TVarType): string;

  function GetIntType(Len: Integer): string;
  begin
    case Len of
      1: Result := 'ShortInt';
      2: Result := 'SmallInt';
      4: Result := 'Integer';
      8: Result := 'Int64';
      else Result := 'Integer';
    end;
  end;

  function GetFloatType(Len: Integer): string;
  begin
    case Len of
       4: Result := 'Single';
       8: Result := 'Double';
      10: Result := 'Extended';
      else Result := 'Double';
    end;
  end;

begin
  case VarType.Code of
    FIELD_ERROR: Result := 'ErrorInType';
    FIELD_INTEGER: Result := GetIntType(VarType.Len);
    FIELD_STRING: Result := 'string';
    FIELD_REAL: Result := GetFloatType(VarType.Len);
    FIELD_GUID: Result := 'TGuid';
    FIELD_BINARY: Result := 'BinaryInNotSupported';
    FIELD_DATETIME, FIELD_DATE, FIELD_TIME: Result := 'TDateTime';
    else Result := 'UnknownType';
  end;
end;

procedure OutDbSignature(var F: TextFile);

var
  DbSignature: string;
  TypeIndex: Integer;
  FieldIndex: Integer;
  LogType: TTypedef;
  Field: TField;
  I: Integer;
  S: string;
  State: Integer;

  procedure Flush();
  begin
    if S = '' then Exit;

    if State = 2 then S := S + '''';
    State := 1;
    WriteLn(F, '    + ', S);
    S := '';
  end;

begin
  DbSignature := '';
  for TypeIndex := 0 to TypedefList.Count - 1 do
  begin
    Pointer(LogType) := TypedefList[TypeIndex];
    DbSignature := DbSignature + 'T ' + LogType.Id + ' ';
    for FieldIndex := 0 to LogType.FieldList.Count - 1 do
    begin
      Pointer(Field) := LogType.FieldList[FieldIndex];
      DbSignature := DbSignature + Iif(Field.Indexed, 'IF ', 'F ');
      DbSignature := DbSignature + Field.Id + ':' + IntToStr(Field.VarType.Code);
      DbSignature := DbSignature + Iif(Field.VarType.Len >= 0, ':' + IntToStr(Field.VarType.Len), '') + ' ';
    end;
  end;

  State := 1;
  S := '';
  DbSignature := Trim(DbSignature);

  for I := 1 to Length(DbSignature) do
  begin
    if DbSignature[I] in [#0.. #31] then
    begin
      if State = 2 then S := S + '''';
      State := 1;
      S := S + '#' + IntToStr(Byte(DbSignature[I]));
    end
    else begin
      if State = 1 then S := S + '''';
      State := 2;
      S := S + DbSignature[I];
      if DbSignature[I] = '''' then
        S := S + DbSignature[I];
    end;

    if Length(S) > 60 then Flush();
  end;

  Flush();
end;

procedure OutLogMethodInterface(var F: TextFile);
var
  I, J, K: Integer;
  Typedef: TTypedef;
  Method: TMethod;
  Arg: TMethodArg;
  Args: string;
  WasType: Boolean;
  NeedVSkip: Boolean;

  procedure VSkip();
  begin
    if not NeedVSkip then Exit;
    WriteLn(F);
    NeedVSkip := False;
  end;

  procedure OutLine(const Line: string); overload;
  begin
    WriteLn(F, Line);
    NeedVSkip := Trim(Line) <> '';
  end;

  procedure OutLine(const Line: string; const Args: array of const); overload;
  begin
    OutLine(Format(Line, Args));
  end;

  procedure OutType();
  begin
    if WasType then Exit;
    OutLine('type');
    WasType := True;
  end;

begin
  WasType := False;
  NeedVSkip := False;

  for I := 0 to TypedefList.Count - 1 do
  begin
    Typedef := TypedefList[I];
    OutType();
    OutLine('  T%sLogType = (log%s);', [Typedef.Id, Typedef.Id]);
  end;

  VSkip();

  for I := 0 to TypedefList.Count - 1 do
  begin
    Typedef := TypedefList[I];
    for J := 0 to Typedef.MethodList.Count - 1 do
    begin
      Method := Typedef.MethodList[J];
      Method.OutputDefinition := '';
      Args := Format('LogType: T%sLogType', [Typedef.Id]);
      for K := 0 to Method.ArgumentList.Count - 1 do
      begin
        Arg := Method.ArgumentList[K];
        Args := Args + Format('; %s%s: %s', [DelphiPrefix(Arg.VarType), Arg.Id, DelphiType(Arg.VarType)]);
      end;
      Method.OutputDefinition := Format('procedure Log(%s);', [Args]);
      OutLine(Method.OutputDefinition + ' overload;');
    end;
  end;

  VSkip();
end;

procedure OutLogMethods(var F: TextFile);
var
  Typedef: TTypedef;
  Method: TMethod;
  Size: Integer;
  SizeExpression: string;
  Mask: Cardinal;

  procedure OutLine(const Line: string = ''); overload;
  begin
    WriteLn(F, Line);
  end;

  procedure OutLine(const Line: string; const Args: array of const); overload;
  begin
    OutLine(Format(Line, Args));
  end;

  procedure CalcSizeAndMask();
  var
    I, J: Integer;
    TypedefField: TField;
    MethodArg: TMethodArg;
  begin
    Size := 8;
    Mask := 0;
    SizeExpression := '';
    for I := 0 to Typedef.FieldList.Count - 1 do
    begin
      TypedefField := Typedef.FieldList[I];
      J := Method.ArgumentList.Count - 1;
      while J >= 0 do
      begin
        MethodArg := Method.ArgumentList[J];
        if MethodArg.Id = TypedefField.Id then Break;
        J := J - 1;
      end;

      if J < 0 then Continue;

      Mask := Mask or (1 shl I);
      case TypedefField.VarType.Code of
        FIELD_STRING:
          begin
            Size := Size + 4;
            SizeExpression := SizeExpression + Format(' + Length(%s)', [TypedefField.Id]);
          end;
        FIELD_BINARY, FIELD_ERROR:
          begin
          end;
        else
          Size := Size + TypedefField.VarType.Len;
      end;
    end;
  end;

  procedure OutMethodBody();
  var
    I: Integer;
    TypedefField: TField;
  begin
    // Build bitmask;
    OutLine('  P := TLogPointer(%d%s);', [Size, SizeExpression]);
    OutLine('  try');
    OutLine('    LogTypeAsInt := Ord(LogType);');
    OutLine('    Mask := $%s;', [IntToHex(Mask, 8)]);
    OutLine();
    OutLine('    P.Put(LogTypeAsInt, 4);');
    OutLine('    P.Put(Mask, 4);');

    for I := 0 to Typedef.FieldList.Count - 1 do
    begin
      if ((1 shl I) and Mask) = 0 then Continue;
      TypedefField := Typedef.FieldList[I];
      if not (TypedefField.VarType.Code in FIXED_LEN_FIELDS) then Continue;
      OutLine('    P.Put(%s, %d);', [TypedefField.Id, TypedefField.VarType.Len]);
    end;

    for I := 0 to Typedef.FieldList.Count - 1 do
    begin
      if ((1 shl I) and Mask) = 0 then Continue;
      TypedefField := Typedef.FieldList[I];
      case TypedefField.VarType.Code of
        FIELD_STRING: OutLine('    P.Put(%s);', [TypedefField.Id]);
      end;
    end;

    OutLine();
    OutLine('    P.Commit();');
    OutLine('  finally');
    OutLine('    P.Free();');
    OutLine('  end;');
  end;

var
  I, J: Integer;
begin
  for I := 0 to TypedefList.Count - 1 do
  begin
    Typedef := TypedefList[I];
    for J := 0 to Typedef.MethodList.Count - 1 do
    begin
      Method := Typedef.MethodList[J];
      OutLine(Method.OutputDefinition);
      CalcSizeAndMask();
      OutLine('var');
      OutLine('  P: TLogPointer;');
      OutLine('  LogTypeAsInt: Integer;');
      OutLine('  Mask: Cardinal;');
      OutLine('begin');
      OutMethodBody();
      OutLine('end;');
      OutLine('');
    end;
  end;
end;

procedure GeneratePas();
var
  FileName: string;
  F: TextFile;
begin
  FileName := GetCurrentDir() + '\MuLog.pas';
  AssignFile(F, FileName);
  ReWrite(F);
  if IOResult <> 0 then
  begin
    WriteLn('Fatal error: can not create file ' + FileName);
    Exit;
  end;

  try
    WriteLn(F, 'unit MuLog;');
    WriteLn(F);
    WriteLn(F, 'interface');
    WriteLn(F);
    OutLogMethodInterface(F);
    WriteLn(F, 'implementation');
    WriteLn(F);
    WriteLn(F, 'const');
    WriteLn(F, '  MuLogDll = ''MuLog.dll'';');
    WriteLn(F);
    WriteLn(F, 'procedure LogInit(DbSignature: PChar); stdcall; external MuLogDll name ''LogInit'';');
    WriteLn(F, 'procedure LogDone(); stdcall; external MuLogDll name ''LogDone'';');
    WriteLn(F, 'function LogAlloc(Size: Integer): Pointer; stdcall; external MuLogDll name ''LogAlloc'';');
    WriteLn(F, 'procedure LogFree(Data: Pointer); stdcall; external MuLogDll name ''LogFree'';');
    WriteLn(F, 'procedure LogAdd(Data: Pointer); stdcall; external MuLogDll name ''LogAdd'';');
    WriteLn(F);
    WriteLn(F, 'const');
    WriteLn(F, '  DB_SIGNATURE = ''''');
    OutDbSignature(F);
    WriteLn(F, '  ;');
    WriteLn(F);
    WriteLn(F, 'type');
    WriteLn(F, '  TLogPointer = class');
    WriteLn(F, '    Base: Pointer;');
    WriteLn(F, '    Pos: PChar;');
    WriteLn(F, '    constructor Create(Size: Integer);');
    WriteLn(F, '    destructor Destroy(); override;');
    WriteLn(F, '    procedure Put(const Data; Size: Integer); overload;');
    WriteLn(F, '    procedure Put(const S: string); overload;');
    WriteLn(F, '    procedure Commit();');
    WriteLn(F, '  end;');
    WriteLn(F);
    WriteLn(F, 'constructor TLogPointer.Create(Size: Integer);');
    WriteLn(F, 'begin');
    WriteLn(F, '  inherited Create();');
    WriteLn(F, '  Base := LogAlloc(Size);');
    WriteLn(F, '  Pos := Base;');
    WriteLn(F, 'end;');
    WriteLn(F);
    WriteLn(F, 'destructor TLogPointer.Destroy();');
    WriteLn(F, 'begin');
    WriteLn(F, '  LogFree(Base);');
    WriteLn(F, '  inherited Destroy();');
    WriteLn(F, 'end;');
    WriteLn(F);
    WriteLn(F, 'procedure TLogPointer.Put(const Data; Size: Integer);');
    WriteLn(F, 'begin');
    WriteLn(F, '  Move(Data, Pos^, Size);');
    WriteLn(F, '  Pos := Pos + Size;');
    WriteLn(F, 'end;');
    WriteLn(F);
    WriteLn(F, 'procedure TLogPointer.Put(const S: string);');
    WriteLn(F, 'var');
    WriteLn(F, '  Size: Integer;');
    WriteLn(F, 'begin');
    WriteLn(F, '  Size := Length(S);');
    WriteLn(F, '  Put(Size, 4);');
    WriteLn(F, '  if Size > 0 then');
    WriteLn(F, '    Put(S[1], Size);');
    WriteLn(F, 'end;');
    WriteLn(F);
    WriteLn(F, 'procedure TLogPointer.Commit();');
    WriteLn(F, 'begin');
    WriteLn(F, '  LogAdd(Base);');
    WriteLn(F, 'end;');
    WriteLn(F);
    OutLogMethods(F);
    WriteLn(F, 'procedure Initialize();');
    WriteLn(F, 'begin');
    WriteLn(F, '  LogInit(DB_SIGNATURE);');
    WriteLn(F, 'end;');
    WriteLn(F);
    WriteLn(F, 'procedure Finalize();');
    WriteLn(F, 'begin');
    WriteLn(F, '  LogDone();');
    WriteLn(F, 'end;');
    WriteLn(F, '');
    WriteLn(F, 'initialization');
    WriteLn(F, '  Initialize();');
    WriteLn(F);
    WriteLn(F, 'finalization');
    WriteLn(F, '  Finalize();');
    WriteLn(F);
    WriteLn(F, 'end.');

    if IOResult <> 0 then
    begin
      WriteLn('Fatal error: can not write to file ' + FileName);
      Exit;
    end;

  finally
    CloseFile(F);
  end;
end;


end.
